
'--------------------------------------------------
' Hands-On 25-1
'--------------------------------------------------

Sub ColorTabs()
    Dim wks As Worksheet
    Dim I As Integer

    I = 5

    For Each wks In ThisWorkbook.Worksheets
        If wks.Tab.ColorIndex = xlColorIndexNone Then
            wks.Tab.ColorIndex = I
            I = I + 1
        End If
    Next
End Sub


'--------------------------------------------------
' Hands-On 25-2
'--------------------------------------------------

Sub ReadNamesWithHighScores()
    Dim v As Integer
    Dim cell As Variant

    v = InputBox("Enter the minimum expected score:", "Approved Minimum")

    For Each cell In ActiveSheet.UsedRange.Columns("B").Cells
        If IsNumeric(cell.Value) And cell.Value >= v Then

            Application.Speech.Speak "Congratulations " & _
            cell.Offset(0, -1).Text
            Application.Speech.Speak " your score is " & cell.Text
        End If
    Next
End Sub


'--------------------------------------------------
' Hands-On 25-3
'--------------------------------------------------

Sub SpellCheck()
    ' set spelling options
    With Application.SpellingOptions
        .SuggestMainOnly = True
        .IgnoreCaps = True
        .IgnoreMixedDigits = True
        .SuggestMainOnly = False
        .IgnoreFileNames = True
        .UserDict = "Special.dic"
    End With

    ' run a spell check
    Cells.CheckSpelling
End Sub


'--------------------------------------------------
' Hands-On 25-4
'--------------------------------------------------

Sub Reformat()
    ' Set search criteria
    With Application.FindFormat.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
    End With

    ' Set replacement criteria
    With Application.ReplaceFormat.Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 11
    End With

    With Application.ReplaceFormat.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With

    ' Perform the replace
    Sheets(1).UsedRange.Replace _
        what:="", _
        Replacement:="", _
        SearchFormat:=True, _
        ReplaceFormat:=True

    ' Reset the Find and Replace formats
    Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
End Sub


'--------------------------------------------------
' Hands-On 25-5
'--------------------------------------------------

Sub Format1stLetters()
    Dim myChr As Characters
    Dim cell As Variant
    Dim I As Integer

    For Each cell In Sheets(1).UsedRange
        If Not IsNumeric(cell) Then
            Set myChr = cell.Characters(1, 1)
            myChr.Font.Color = RGB(128, 0, 255)
            For I = 1 To Len(cell.Text)
                If Asc(Mid(cell, I, 1)) = 32 Then
                    Set myChr = cell.Characters(I + 1, 1)
                    myChr.Font.Color = RGB(255, 0, 0)
                End If
            Next
        End If
    Next
End Sub



'--------------------------------------------------
' Hands-On 25-6
'--------------------------------------------------

' this procedure generates a list of AutoCorrect entries
Sub Auto_Correct()
    Dim myList As Variant
    Dim I As Integer

    myList = Application.AutoCorrect.ReplacementList
    ActiveSheet.Cells(1, 1).Select
    For I = LBound(myList) To UBound(myList)
        With ActiveCell
            .Offset(0, 0).Value = myList(I, 1)
            .Offset(0, 1).Value = myList(I, 2)
            .Offset(1, 0).Select
        End With
    Next
    ActiveSheet.Columns("A:B").AutoFit
    Cells(1, 1).Select
End Sub

' this procedure adds new worksheet entries to the AutoCorrect list
Sub Auto_Correct_Batch_Add()
    Dim myRange As Range
    Dim myList As Variant
    Dim strReplaceWhat As String
    Dim strReplaceWith As String
    Dim I As Integer

    ' prompt user to select data for processing
    ' the Type argument ensures that the return value is
    ' a valid cell reference (a Range object).
    Set myRange = Application.InputBox( _
        Prompt:="Highlight the range containing your list", _
        Title:="List Selection", _
        Type:=8)
    If myRange.Columns.Count <> 2 Then Exit Sub

    ' save all the values in the selected range to an array
    myList = myRange.Value

    ' retrieve the values from the array and
    ' add them to the AutoCorrect replacements
    For I = LBound(myList) To UBound(myList)
        strReplaceWhat = myList(I, 1)
        strReplaceWith = myList(I, 2)
        If strReplaceWhat <> "" And strReplaceWith <> "" Then
            Application.AutoCorrect.AddReplacement _
                    strReplaceWhat, strReplaceWith
        End If
    Next
End Sub


'--------------------------------------------------
' Hands-On 25-7
'--------------------------------------------------

Sub ApplyConditionalFormat()
    Dim objFormatCon As FormatCondition
    Dim objFormatColl As FormatConditions
    Dim myRange As Range

    ' select range containing numeric cells only
    Set myRange = ActiveSheet.UsedRange. _
        SpecialCells(xlCellTypeConstants, 1)
    Set objFormatColl = myRange.FormatConditions

    ' find out if any conditional formatting already exists
    If objFormatColl.Count > 0 Then
        MsgBox "There are " & objFormatColl.Count & " conditions " & _
            "defined for the used range."
    End If

    ' remove existing conditions if they exist
    For Each objFormatCon In objFormatColl
        objFormatCon.Delete
    Next

    ' add first condition
    Set objFormatCon = objFormatColl.Add(Type:=xlCellValue, _
        Operator:=xlGreaterEqual, _
        Formula1:="150")
    With objFormatCon
        .Font.Bold = True
        .Font.ColorIndex = 2 ' white
        .Interior.Pattern = xlSolid
        .Interior.Color = RGB(0, 0, 255) ' blue
    End With
End Sub


'--------------------------------------------------
' Hands-On 25-8
'--------------------------------------------------

Sub AddWatermarkImage()
    Dim strFileName As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Custom image selection"
        .AllowMultiSelect = False
        .Filters.Add "Pictures", "*.gif; *.jpg; *.jpeg; *.bmp", 1
        .InitialView = msoFileDialogViewThumbnail
        If .Show = -1 Then
            strFileName = .SelectedItems(1)
            With ActiveSheet.PageSetup
                With .LeftHeaderPicture
                    .Filename = strFileName
                    .Brightness = 0.85
                    .ColorType = msoPictureWatermark
                    .Contrast = 0.15
                    .Height = 72
                    .Width = 72
                End With
                .TopMargin = Application.InchesToPoints(2.25)
                .LeftHeader = "&G"
            End With
        End If
    End With
End Sub


'--------------------------------------------------
' Hands-On 25-9
'--------------------------------------------------

Sub StoreScores()
    Dim mySheet As Worksheet
    Dim custPrp As CustomProperty
    Dim I As Integer
    Dim rng As Range
    Dim totalCount As Integer

    Set mySheet = ThisWorkbook.Sheets(1)

    ' find out if custom properties exist
    If mySheet.CustomProperties.Count > 0 Then
        ' Display custom properties
        totalCount = mySheet.CustomProperties.Count

        For I = 1 To totalCount
            With mySheet.CustomProperties(1)
                Debug.Print .Name & vbTab; .Value
                Set rng = mySheet.Range("A:A").Find(what:=.Name)
                ' Delete the custom property
                 If Not rng Is Nothing Then .Delete
            End With
        Next
    End If

    mySheet.Activate
    Cells(2, 1).Select
    Do While ActiveCell <> ""
        If Not IsEmpty(ActiveCell) Then
            Set custPrp = mySheet.CustomProperties.Add( _
            Name:=ActiveCell.Text, _
            Value:=ActiveCell.Offset(0, 1).Text)
            Debug.Print custPrp.Name & vbTab & custPrp.Value
            ActiveCell.Offset(1, 0).Select
        End If
    Loop

    If mySheet.CustomProperties.Count > 0 Then
        ' Display custom properties
        For I = 1 To mySheet.CustomProperties.Count
            With mySheet.CustomProperties(I)
                Debug.Print .Name & vbTab; .Value
            End With
        Next
    End If
End Sub


Sub SortData()
    Range("A2").Select
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A6"), _
            SortOn:=xlSortOnValues, _
            Order:=xlDescending, _
            DataOption:=xlSortNormal
        .SetRange Range("A1:B6")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    MsgBox "Data has been sorted.", vbInformation
End Sub


'--------------------------------------------------
' Hands-On 25-10
'--------------------------------------------------

Function IsCompatible() As Boolean
    If Application.Version = "12.0" Then
        If ActiveWorkbook.Excel8CompatibilityMode Then
            IsCompatible = False
        Else
            IsCompatible = True
        End If
    End If
End Function

Sub CheckCompatibility()
    Windows("Assets.xls").Activate
    If Not IsCompatible Then
        MsgBox "Excel 2007 features will not work " & _
            "in this workbook.", vbCritical, _
            "Excel 97-2003 Compatibility Workbook"
            
    End If
End Sub

